home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / gfa / gfaexprt.lzh / GFAXPERT.LIB / STANHIGH.LST < prev    next >
Encoding:
File List  |  1986-10-19  |  7.0 KB  |  237 lines
  1. ' *** STANHIGH.LST ***        (delete this line)
  2. '
  3. ' ==============================================================================
  4. ' ********************
  5. ' ***         .GFA ***
  6. ' ********************
  7. ' *** this program runs in High resolution only
  8. '
  9. ' ------------------------------------------------------------------------------
  10. '                             *** Initiation ***
  11. '
  12. DEFWRD "a-z"                    ! word variables (-32768 to +32767) default !!
  13. @initio
  14. '
  15. ' @title.screen("TITLE",".. .... 1990",32)        ! activate in finished program
  16. ' ON BREAK GOSUB break                            ! activate in finished program
  17. '
  18. ' ------------------------------------------------------------------------------
  19. '                            *** Main Program ***
  20. '
  21. '
  22. '
  23. EDIT                            ! use this while developing program
  24. ' @exit                         ! use this in finished program
  25. '
  26. ' ------------------------------------------------------------------------------
  27. '                           *** Standard Globals ***
  28. '
  29. > PROCEDURE initio
  30.   LOCAL w,h
  31.   '
  32.   CLS
  33.   @high.mode                    ! test if High resolution
  34.   high.res!=TRUE                ! resolution-flag
  35.   '
  36.   @get.path(default.path$)      ! current folder
  37.   '
  38.   physbase%=XBIOS(2)            ! physical screen
  39.   logbase%=XBIOS(3)             ! logical screen
  40.   '
  41.   scrn.x.max=WORK_OUT(0)                            ! x: 0-639 (regular monitor)
  42.   scrn.y.max=WORK_OUT(1)                            ! y: 0-399
  43.   ~GRAF_HANDLE(char.width,char.height,w,h)          ! 8x16 system-font
  44.   scrn.col.max=DIV(SUCC(scrn.x.max),char.width)     ! 80 columns
  45.   scrn.lin.max=DIV(SUCC(scrn.y.max),char.height)    ! 25 lines
  46.   '
  47.   white=0                       ! default colors
  48.   black=1
  49.   VSETCOLOR 1,0                 ! normal screen (black letters on white screen)
  50.   DEFTEXT black,0,0,13          ! TEXT-font same as system-font
  51.   '
  52.   ' *** create Standard Array color.index()
  53.   DIM color.index(1)
  54.   color.index(0)=0
  55.   color.index(1)=1
  56.   '
  57.   on!=TRUE                      ! switch-flags
  58.   off!=FALSE
  59.   '
  60.   bel$=CHR$(7)                  ! 'PRINT bel$;' for bell
  61.   '
  62.   return$=CHR$(13)              ! define some important keys
  63.   esc$=CHR$(27)
  64.   help$=CHR$(0)+CHR$(98)
  65.   undo$=CHR$(0)+CHR$(97)
  66.   '
  67.   interpreter$="\GFABASIC.PRG"  ! change path if necessary
  68.   run.only$="\GFABASRO.PRG"     ! Run-Only Interpreter
  69.   start.gfa$="\START.GFA"       ! 'Shell' for GFA-programs
  70.   start.prg$="\GFASTART.PRG"    ! 'Shell' for compiled GFA-programs
  71.   '
  72. RETURN
  73. ' **********
  74. '
  75. ' ------------------------------------------------------------------------------
  76. '                          *** Standard Functions ***
  77. '
  78. DEFFN center$(text$)=SPACE$((scrn.col.max-LEN(text$))/2)+text$
  79. DEFFN rev$(txt$)=CHR$(27)+"p"+txt$+CHR$(27)+"q"
  80. '
  81. ' ------------------------------------------------------------------------------
  82. '                         *** Standard Procedures ***
  83. '
  84. > PROCEDURE high.mode
  85.   ' *** uses Procedure Exit
  86.   LOCAL m$,button
  87.   IF XBIOS(4)<>2
  88.     SOUND 1,10,12,4,25
  89.     SOUND 1,10,6,4,25
  90.     SOUND 1,10,12,4,50
  91.     SOUND 1,0
  92.     m$="Sorry, only|High resolution|for this|program !!"
  93.     ALERT 3,m$,1," OK ",button
  94.     @exit
  95.   ENDIF
  96. RETURN
  97. ' **********
  98. '
  99. > PROCEDURE get.path(VAR default.path$)
  100.   ' *** return default path (current drive and folder)
  101.   ' *** example - A:\GAMES\
  102.   ' *** WARNING : Procedure returns path$ only after CHDIR path$, else A:\
  103.   ' ***                          (even if program not in main directory !!)
  104.   LOCAL default.drive,default.drive$
  105.   CLR default.path$
  106.   default.drive=GEMDOS(&H19)
  107.   default.drive$=CHR$(default.drive+65)
  108.   default.path$=DIR$(default.drive+1)
  109.   IF default.path$<>""
  110.     default.path$=default.drive$+":"+default.path$+"\"
  111.   ELSE
  112.     default.path$=default.drive$+":\"
  113.   ENDIF
  114. RETURN
  115. ' **********
  116. '
  117. > PROCEDURE title.screen(title$,datum$,height)
  118.   ' *** standard title-screen
  119.   ' *** uses Standard Globals and Standard Procedure Return.key
  120.   LOCAL x,y,col,lin,name$,x1,y1,x2,y2,i
  121.   CLS
  122.   HIDEM
  123.   DEFTEXT black,8,0,height
  124.   x=(scrn.x.max-LEN(title$)*height/2)/2
  125.   y=scrn.y.max/2
  126.   TEXT x,y,title$
  127.   LET name$="© Han Kempen"      ! that's me
  128.   col=(scrn.col.max-12)/2
  129.   lin=scrn.lin.max/2+6
  130.   PRINT AT(col,lin);name$
  131.   x1=(col-2)*8
  132.   y1=(lin-1)*char.height-4
  133.   x2=x1+LEN(name$)*8+16
  134.   y2=y1+char.height+8
  135.   BOX x1,y1,x2,y2
  136.   DEFLINE 1,3
  137.   DRAW x1+3,y2+2 TO x2+2,y2+2 TO x2+2,y1+3
  138.   LINE x1+3,y2+1,x2+2,y2+1
  139.   PRINT AT(col,lin+2);datum$
  140.   @return.key
  141.   COLOR black
  142.   DEFLINE 1,1
  143.   FOR i=0 TO y
  144.     BOX i,i,scrn.x.max-i,scrn.y.max-i
  145.   NEXT i
  146.   COLOR white
  147.   FOR i=y DOWNTO 0
  148.     BOX i,i,scrn.x.max-i,scrn.y.max-i
  149.   NEXT i
  150.   COLOR black
  151.   CLS
  152. RETURN
  153. ' **********
  154. '
  155. > PROCEDURE return.key
  156.   ' *** wait for <Return>
  157.   ' *** after pressing any other key, flashing 'RETURN' is turned off
  158.   ' *** uses Standard Globals
  159.   LOCAL w1$,w2$,temp$,in$
  160.   CLR in$
  161.   REPEAT
  162.   UNTIL INKEY$=""
  163.   GET 0,scrn.y.max-char.height,scrn.x.max,scrn.y.max,temp$
  164.   w1$="<RETURN>"
  165.   w2$=SPACE$(8)
  166.   PRINT AT(scrn.col.max/2-3,scrn.lin.max);w1$;
  167.   WHILE in$=""                              ! wait for any key
  168.     PAUSE 30
  169.     SWAP w1$,w2$
  170.     PRINT AT(scrn.col.max/2-3,scrn.lin.max);w1$;
  171.     in$=INKEY$
  172.   WEND
  173.   PUT 0,scrn.y.max-char.height,temp$,3      ! restore screen
  174.   WHILE in$<>return$                        ! wait for <Return>
  175.     in$=INKEY$
  176.   WEND
  177. RETURN
  178. ' **********
  179. '
  180. > PROCEDURE break
  181.   ' *** activate in main program with : ON BREAK GOSUB break
  182.   ' *** do not use while developing program !
  183.   LOCAL m$,k
  184.   ON BREAK CONT
  185.   m$="*** Break ***|Continue,|Run again|or Quit"
  186.   ALERT 3,m$,1,"CONT|RUN|QUIT",k
  187.   SELECT k
  188.   CASE 1
  189.     ON BREAK                            ! true break possible for emergency
  190.     m$="Freeze current|screen (press|any key to|continue)"
  191.     ALERT 2,m$,2,"YES|NO",k
  192.     IF k=1
  193.       REPEAT
  194.       UNTIL LEN(INKEY$) OR MOUSEK
  195.     ENDIF
  196.     ON BREAK GOSUB break
  197.   CASE 2
  198.     RUN
  199.   CASE 3
  200.     @exit
  201.   ENDSELECT
  202. RETURN
  203. ' **********
  204. '
  205. > PROCEDURE exit
  206.   ' *** exit program
  207.   CLS
  208.   IF EXIST(interpreter$) OR EXIST(run.only$)
  209.     ' *** program was run from (Run-Only) Interpreter
  210.     IF EXIST(start.gfa$)
  211.       CHAIN start.gfa$          ! back to 'shell'-program
  212.     ELSE
  213.       EDIT                      ! no shell
  214.     ENDIF
  215.   ELSE IF EXIST(start.gfa$)
  216.     ' *** can't find interpreter, but here is the 'shell'-program
  217.     CHAIN start.gfa$
  218.   ELSE IF EXIST(start.prg$)
  219.     ' *** compiled program started from shell
  220.     CHAIN start.prg$            ! back to shell
  221.   ELSE
  222.     ' *** compiled program
  223.     SYSTEM                      ! no shell
  224.   ENDIF
  225. RETURN
  226. ' **********
  227. '
  228. ' ------------------------------------------------------------------------------
  229. '                               *** Procedures ***
  230. '
  231. '
  232. '
  233. '
  234. ' ------------------------------------------------------------------------------
  235. '                                *** The End ***
  236. ' ==============================================================================
  237.